home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / trnscrpt.scm < prev    next >
Text File  |  1999-04-19  |  2KB  |  77 lines
  1. ; "trnscrpt.scm", transcript functions for Scheme.
  2. ; Copyright (c) 1992, 1993, 1995 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define transcript:port #f)
  21.  
  22. (define (transcript-on filename)
  23.   (set! transcript:port (open-output-file filename)))
  24.  
  25. (define (transcript-off)
  26.   (if (output-port? transcript:port)
  27.       (close-output-port transcript:port))
  28.   (set! transcript:port #f))
  29.  
  30. (define read-char
  31.   (let ((read-char read-char) (write-char write-char))
  32.     (lambda opt
  33.       (let ((ans (apply read-char opt)))
  34.     (cond ((eof-object? ans))
  35.           ((output-port? transcript:port)
  36.            (write-char ans transcript:port)))
  37.     ans))))
  38.  
  39. (define read
  40.   (let ((read read) (write write) (newline newline))
  41.     (lambda opt
  42.       (let ((ans (apply read opt)))
  43.     (cond ((eof-object? ans))
  44.           ((output-port? transcript:port)
  45.            (write ans transcript:port)
  46.            (if (eqv? #\newline (apply peek-char opt))
  47.            (newline transcript:port))))
  48.     ans))))
  49.  
  50. (define write-char
  51.   (let ((write-char write-char))
  52.     (lambda (obj . opt)
  53.       (apply write-char obj opt)
  54.       (if (output-port? transcript:port)
  55.       (write-char obj transcript:port)))))
  56.  
  57. (define write
  58.   (let ((write write))
  59.     (lambda (obj . opt)
  60.       (apply write obj opt)
  61.       (if (output-port? transcript:port)
  62.       (write obj transcript:port)))))
  63.  
  64. (define display
  65.   (let ((display display))
  66.     (lambda (obj . opt)
  67.       (apply display obj opt)
  68.       (if (output-port? transcript:port)
  69.       (display obj transcript:port)))))
  70.  
  71. (define newline
  72.   (let ((newline newline))
  73.     (lambda opt
  74.       (apply newline opt)
  75.       (if (output-port? transcript:port)
  76.       (newline transcript:port)))))
  77.